home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1998 February / Macworld (1998-02).dmg / Shareware World / Network / TeamWave 2.1 / TeamWave Server / TeamWave Server.rsrc / TEXT_0_Init.txt < prev    next >
Text File  |  1997-11-24  |  21KB  |  703 lines
  1. # init.tcl --
  2. #
  3. # Default system startup file for Tcl-based applications.  Defines
  4. # "unknown" procedure and auto-load facilities.
  5. #
  6. # SCCS: @(#) init.tcl 1.86 97/08/08 10:37:39
  7. #
  8. # Copyright (c) 1991-1993 The Regents of the University of California.
  9. # Copyright (c) 1994-1996 Sun Microsystems, Inc.
  10. #
  11. # See the file "license.terms" for information on usage and redistribution
  12. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  13. #
  14.  
  15. if {[info commands package] == ""} {
  16.     error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]"
  17. }
  18. package require -exact Tcl 8.0
  19.  
  20. # Compute the auto path to use in this interpreter.
  21. # (auto_path could be already set, in safe interps for instance)
  22. if {![info exists auto_path]} {
  23.     if [catch {set auto_path $env(TCLLIBPATH)}] {
  24.     set auto_path ""
  25.     }
  26. }
  27. if {[lsearch -exact $auto_path [info library]] < 0} {
  28.     lappend auto_path [info library]
  29. }
  30. catch {
  31.     foreach dir $tcl_pkgPath {
  32.     if {[lsearch -exact $auto_path $dir] < 0} {
  33.         lappend auto_path $dir
  34.     }
  35.     }
  36.     unset dir
  37. }
  38.  
  39. # Conditionalize for presence of exec.
  40.  
  41. package unknown tclPkgUnknown
  42. if {[info commands exec] == ""} {
  43.  
  44.     # Some machines, such as the Macintosh, do not have exec. Also, on all
  45.     # platforms, safe interpreters do not have exec.
  46.  
  47.     set auto_noexec 1
  48. }
  49. set errorCode ""
  50. set errorInfo ""
  51.  
  52. # Define a log command (which can be overwitten to log errors
  53. # differently, specially when stderr is not available)
  54.  
  55. if {[info commands tclLog] == ""} {
  56.     proc tclLog {string} {
  57.     catch {puts stderr $string}
  58.     }
  59. }
  60.  
  61. # unknown --
  62. # This procedure is called when a Tcl command is invoked that doesn't
  63. # exist in the interpreter.  It takes the following steps to make the
  64. # command available:
  65. #
  66. #    1. See if the autoload facility can locate the command in a
  67. #       Tcl script file.  If so, load it and execute it.
  68. #    2. If the command was invoked interactively at top-level:
  69. #        (a) see if the command exists as an executable UNIX program.
  70. #        If so, "exec" the command.
  71. #        (b) see if the command requests csh-like history substitution
  72. #        in one of the common forms !!, !<number>, or ^old^new.  If
  73. #        so, emulate csh's history substitution.
  74. #        (c) see if the command is a unique abbreviation for another
  75. #        command.  If so, invoke the command.
  76. #
  77. # Arguments:
  78. # args -    A list whose elements are the words of the original
  79. #        command, including the command name.
  80.  
  81. proc unknown args {
  82.     global auto_noexec auto_noload env unknown_pending tcl_interactive
  83.     global errorCode errorInfo
  84.  
  85.     # Save the values of errorCode and errorInfo variables, since they
  86.     # may get modified if caught errors occur below.  The variables will
  87.     # be restored just before re-executing the missing command.
  88.  
  89.     set savedErrorCode $errorCode
  90.     set savedErrorInfo $errorInfo
  91.     set name [lindex $args 0]
  92.     if ![info exists auto_noload] {
  93.     #
  94.     # Make sure we're not trying to load the same proc twice.
  95.     #
  96.     if [info exists unknown_pending($name)] {
  97.         return -code error "self-referential recursion in \"unknown\" for command \"$name\"";
  98.     }
  99.     set unknown_pending($name) pending;
  100.     set ret [catch {auto_load $name} msg]
  101.     unset unknown_pending($name);
  102.     if {$ret != 0} {
  103.         return -code $ret -errorcode $errorCode \
  104.         "error while autoloading \"$name\": $msg"
  105.     }
  106.     if ![array size unknown_pending] {
  107.         unset unknown_pending
  108.     }
  109.     if $msg {
  110.         set errorCode $savedErrorCode
  111.         set errorInfo $savedErrorInfo
  112.         set code [catch {uplevel 1 $args} msg]
  113.         if {$code ==  1} {
  114.         #
  115.         # Strip the last five lines off the error stack (they're
  116.         # from the "uplevel" command).
  117.         #
  118.  
  119.         set new [split $errorInfo \n]
  120.         set new [join [lrange $new 0 [expr [llength $new] - 6]] \n]
  121.         return -code error -errorcode $errorCode \
  122.             -errorinfo $new $msg
  123.         } else {
  124.         return -code $code $msg
  125.         }
  126.     }
  127.     }
  128.     if {([info level] == 1) && ([info script] == "") \
  129.         && [info exists tcl_interactive] && $tcl_interactive} {
  130.     if ![info exists auto_noexec] {
  131.         set new [auto_execok $name]
  132.         if {$new != ""} {
  133.         set errorCode $savedErrorCode
  134.         set errorInfo $savedErrorInfo
  135.         set redir ""
  136.         if {[info commands console] == ""} {
  137.             set redir ">&@stdout <@stdin"
  138.         }
  139.         return [uplevel exec $redir $new [lrange $args 1 end]]
  140.         }
  141.     }
  142.     set errorCode $savedErrorCode
  143.     set errorInfo $savedErrorInfo
  144.     if {$name == "!!"} {
  145.         set newcmd [history event]
  146.     } elseif {[regexp {^!(.+)$} $name dummy event]} {
  147.         set newcmd [history event $event]
  148.     } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new]} {
  149.         set newcmd [history event -1]
  150.         catch {regsub -all -- $old $newcmd $new newcmd}
  151.     }
  152.     if [info exists newcmd] {
  153.         tclLog $newcmd
  154.         history change $newcmd 0
  155.         return [uplevel $newcmd]
  156.     }
  157.  
  158.     set ret [catch {set cmds [info commands $name*]} msg]
  159.     if {[string compare $name "::"] == 0} {
  160.         set name ""
  161.     }
  162.     if {$ret != 0} {
  163.         return -code $ret -errorcode $errorCode \
  164.         "error in unknown while checking if \"$name\" is a unique command abbreviation: $msg"
  165.     }
  166.     if {[llength $cmds] == 1} {
  167.         return [uplevel [lreplace $args 0 0 $cmds]]
  168.     }
  169.     if {[llength $cmds] != 0} {
  170.         if {$name == ""} {
  171.         return -code error "empty command name \"\""
  172.         } else {
  173.         return -code error \
  174.             "ambiguous command name \"$name\": [lsort $cmds]"
  175.         }
  176.     }
  177.     }
  178.     return -code error "invalid command name \"$name\""
  179. }
  180.  
  181. # auto_load --
  182. # Checks a collection of library directories to see if a procedure
  183. # is defined in one of them.  If so, it sources the appropriate
  184. # library file to create the procedure.  Returns 1 if it successfully
  185. # loaded the procedure, 0 otherwise.
  186. #
  187. # Arguments: 
  188. # cmd -            Name of the command to find and load.
  189.  
  190. proc auto_load cmd {
  191.     global auto_index auto_oldpath auto_path env errorInfo errorCode
  192.  
  193.     foreach name [list $cmd ::$cmd] {
  194.     if [info exists auto_index($name)] {
  195.         uplevel #0 $auto_index($name)
  196.         return [expr {[info commands $name] != ""}]
  197.     }
  198.     }
  199.     if ![info exists auto_path] {
  200.     return 0
  201.     }
  202.     if [info exists auto_oldpath] {
  203.     if {$auto_oldpath == $auto_path} {
  204.         return 0
  205.     }
  206.     }
  207.     set auto_oldpath $auto_path
  208.  
  209.     # Check if we are a safe interpreter. In that case, we support only
  210.     # newer format tclIndex files.
  211.  
  212.     set issafe [interp issafe]
  213.     for {set i [expr [llength $auto_path] - 1]} {$i >= 0} {incr i -1} {
  214.     set dir [lindex $auto_path $i]
  215.     set f ""
  216.     if {$issafe} {
  217.         catch {source [file join $dir tclIndex]}
  218.     } elseif [catch {set f [open [file join $dir tclIndex]]}] {
  219.         continue
  220.     } else {
  221.         set error [catch {
  222.         set id [gets $f]
  223.         if {$id == "# Tcl autoload index file, version 2.0"} {
  224.             eval [read $f]
  225.         } elseif {$id == \
  226.             "# Tcl autoload index file: each line identifies a Tcl"} {
  227.             while {[gets $f line] >= 0} {
  228.             if {([string index $line 0] == "#")
  229.                 || ([llength $line] != 2)} {
  230.                 continue
  231.             }
  232.             set name [lindex $line 0]
  233.             set auto_index($name) \
  234.                 "source [file join $dir [lindex $line 1]]"
  235.             }
  236.         } else {
  237.             error \
  238.               "[file join $dir tclIndex] isn't a proper Tcl index file"
  239.         }
  240.         } msg]
  241.         if {$f != ""} {
  242.         close $f
  243.         }
  244.         if $error {
  245.         error $msg $errorInfo $errorCode
  246.         }
  247.     }
  248.     }
  249.     if [info exists auto_index($cmd)] {
  250.     uplevel #0 $auto_index($cmd)
  251.     if {[info commands $cmd] != ""} {
  252.         return 1
  253.     }
  254.     }
  255.     return 0
  256. }
  257.  
  258. if {[string compare $tcl_platform(platform) windows] == 0} {
  259.  
  260. # auto_execok --
  261. #
  262. # Returns string that indicates name of program to execute if 
  263. # name corresponds to a shell builtin or an executable in the
  264. # Windows search path, or "" otherwise.  Builds an associative 
  265. # array auto_execs that caches information about previous checks, 
  266. # for speed.
  267. #
  268. # Arguments: 
  269. # name -            Name of a command.
  270.  
  271. # Windows version.
  272. #
  273. # Note that info executable doesn't work under Windows, so we have to
  274. # look for files with .exe, .com, or .bat extensions.  Also, the path
  275. # may be in the Path or PATH environment variables, and path
  276. # components are separated with semicolons, not colons as under Unix.
  277. #
  278. proc auto_execok name {
  279.     global auto_execs env tcl_platform
  280.  
  281.     if [info exists auto_execs($name)] {
  282.     return $auto_execs($name)
  283.     }
  284.     set auto_execs($name) ""
  285.  
  286.     if {[lsearch -exact {cls copy date del erase dir echo mkdir md rename 
  287.         ren rmdir rd time type ver vol} $name] != -1} {
  288.     return [set auto_execs($name) [list $env(COMSPEC) /c $name]]
  289.     }
  290.  
  291.     if {[llength [file split $name]] != 1} {
  292.     foreach ext {{} .com .exe .bat} {
  293.         set file ${name}${ext}
  294.         if {[file exists $file] && ![file isdirectory $file]} {
  295.         return [set auto_execs($name) [list $file]]
  296.         }
  297.     }
  298.     return ""
  299.     }
  300.  
  301.     set path "[file dirname [info nameof]];.;"
  302.     if {[info exists env(WINDIR)]} {
  303.     set windir $env(WINDIR) 
  304.     }
  305.     if {[info exists windir]} {
  306.     if {$tcl_platform(os) == "Windows NT"} {
  307.         append path "$windir/system32;"
  308.     }
  309.     append path "$windir/system;$windir;"
  310.     }
  311.  
  312.     if {[info exists env(PATH)]} {
  313.     append path $env(PATH)
  314.     }
  315.  
  316.     foreach dir [split $path {;}] {
  317.     if {$dir == ""} {
  318.         set dir .
  319.     }
  320.     foreach ext {{} .com .exe .bat} {
  321.         set file [file join $dir ${name}${ext}]
  322.         if {[file exists $file] && ![file isdirectory $file]} {
  323.         return [set auto_execs($name) [list $file]]
  324.         }
  325.     }
  326.     }
  327.     return ""
  328. }
  329.  
  330. } else {
  331.  
  332. # auto_execok --
  333. #
  334. # Returns string that indicates name of program to execute if 
  335. # name corresponds to an executable in the path. Builds an associative 
  336. # array auto_execs that caches information about previous checks, 
  337. # for speed.
  338. #
  339. # Arguments: 
  340. # name -            Name of a command.
  341.  
  342. # Unix version.
  343. #
  344. proc auto_execok name {
  345.     global auto_execs env
  346.  
  347.     if [info exists auto_execs($name)] {
  348.     return $auto_execs($name)
  349.     }
  350.     set auto_execs($name) ""
  351.     if {[llength [file split $name]] != 1} {
  352.     if {[file executable $name] && ![file isdirectory $name]} {
  353.         set auto_execs($name) [list $name]
  354.     }
  355.     return $auto_execs($name)
  356.     }
  357.     foreach dir [split $env(PATH) :] {
  358.     if {$dir == ""} {
  359.         set dir .
  360.     }
  361.     set file [file join $dir $name]
  362.     if {[file executable $file] && ![file isdirectory $file]} {
  363.         set auto_execs($name) [list $file]
  364.         return $auto_execs($name)
  365.     }
  366.     }
  367.     return ""
  368. }
  369.  
  370. }
  371. # auto_reset --
  372. # Destroy all cached information for auto-loading and auto-execution,
  373. # so that the information gets recomputed the next time it's needed.
  374. # Also delete any procedures that are listed in the auto-load index
  375. # except those defined in this file.
  376. #
  377. # Arguments: 
  378. # None.
  379.  
  380. proc auto_reset {} {
  381.     global auto_execs auto_index auto_oldpath
  382.     foreach p [info procs] {
  383.     if {[info exists auto_index($p)] && ![string match auto_* $p]
  384.         && ([lsearch -exact {unknown pkg_mkIndex tclPkgSetup
  385.             tclPkgUnknown} $p] < 0)} {
  386.         rename $p {}
  387.     }
  388.     }
  389.     catch {unset auto_execs}
  390.     catch {unset auto_index}
  391.     catch {unset auto_oldpath}
  392. }
  393.  
  394. # auto_mkindex --
  395. # Regenerate a tclIndex file from Tcl source files.  Takes as argument
  396. # the name of the directory in which the tclIndex file is to be placed,
  397. # followed by any number of glob patterns to use in that directory to
  398. # locate all of the relevant files.
  399. #
  400. # Arguments: 
  401. # dir -            Name of the directory in which to create an index.
  402. # args -        Any number of additional arguments giving the
  403. #            names of files within dir.  If no additional
  404. #            are given auto_mkindex will look for *.tcl.
  405.  
  406. proc auto_mkindex {dir args} {
  407.     global errorCode errorInfo
  408.     set oldDir [pwd]
  409.     cd $dir
  410.     set dir [pwd]
  411.     append index "# Tcl autoload index file, version 2.0\n"
  412.     append index "# This file is generated by the \"auto_mkindex\" command\n"
  413.     append index "# and sourced to set up indexing information for one or\n"
  414.     append index "# more commands.  Typically each line is a command that\n"
  415.     append index "# sets an element in the auto_index array, where the\n"
  416.     append index "# element name is the name of a command and the value is\n"
  417.     append index "# a script that loads the command.\n\n"
  418.     if {$args == ""} {
  419.     set args *.tcl
  420.     }
  421.     foreach file [eval glob $args] {
  422.     set f ""
  423.     set error [catch {
  424.         set f [open $file]
  425.         while {[gets $f line] >= 0} {
  426.         if [regexp {^proc[     ]+([^     ]*)} $line match procName] {
  427.             append index "set [list auto_index($procName)]"
  428.             append index " \[list source \[file join \$dir [list $file]\]\]\n"
  429.         }
  430.         }
  431.         close $f
  432.     } msg]
  433.     if $error {
  434.         set code $errorCode
  435.         set info $errorInfo
  436.         catch {close $f}
  437.         cd $oldDir
  438.         error $msg $info $code
  439.     }
  440.     }
  441.     set f ""
  442.     set error [catch {
  443.     set f [open tclIndex w]
  444.     puts $f $index nonewline
  445.     close $f
  446.     cd $oldDir
  447.     } msg]
  448.     if $error {
  449.     set code $errorCode
  450.     set info $errorInfo
  451.     catch {close $f}
  452.     cd $oldDir
  453.     error $msg $info $code
  454.     }
  455. }
  456.  
  457. # pkg_mkIndex --
  458. # This procedure creates a package index in a given directory.  The
  459. # package index consists of a "pkgIndex.tcl" file whose contents are
  460. # a Tcl script that sets up package information with "package require"
  461. # commands.  The commands describe all of the packages defined by the
  462. # files given as arguments.
  463. #
  464. # Arguments:
  465. # dir -            Name of the directory in which to create the index.
  466. # args -        Any number of additional arguments, each giving
  467. #            a glob pattern that matches the names of one or
  468. #            more shared libraries or Tcl script files in
  469. #            dir.
  470.  
  471. proc pkg_mkIndex {dir args} {
  472.     global errorCode errorInfo
  473.     if {[llength $args] == 0} {
  474.     return -code error "wrong # args: should be\
  475.         \"pkg_mkIndex dir pattern ?pattern ...?\"";
  476.     }
  477.     append index "# Tcl package index file, version 1.0\n"
  478.     append index "# This file is generated by the \"pkg_mkIndex\" command\n"
  479.     append index "# and sourced either when an application starts up or\n"
  480.     append index "# by a \"package unknown\" script.  It invokes the\n"
  481.     append index "# \"package ifneeded\" command to set up package-related\n"
  482.     append index "# information so that packages will be loaded automatically\n"
  483.     append index "# in response to \"package require\" commands.  When this\n"
  484.     append index "# script is sourced, the variable \$dir must contain the\n"
  485.     append index "# full path name of this file's directory.\n"
  486.     set oldDir [pwd]
  487.     cd $dir
  488.     foreach file [eval glob $args] {
  489.     # For each file, figure out what commands and packages it provides.
  490.     # To do this, create a child interpreter, load the file into the
  491.     # interpreter, and get a list of the new commands and packages
  492.     # that are defined.  Define an empty "package unknown" script so
  493.     # that there are no recursive package inclusions.
  494.  
  495.     set c [interp create]
  496.  
  497.     # If Tk is loaded in the parent interpreter, load it into the
  498.     # child also, in case the extension depends on it.
  499.  
  500.     foreach pkg [info loaded] {
  501.         if {[lindex $pkg 1] == "Tk"} {
  502.         $c eval {set argv {-geometry +0+0}}
  503.         load [lindex $pkg 0] Tk $c
  504.         break
  505.         }
  506.     }
  507.     $c eval [list set file $file]
  508.     if [catch {
  509.         $c eval {
  510.         proc dummy args {}
  511.         rename package package-orig
  512.         proc package {what args} {
  513.             switch -- $what {
  514.             require { return ; # ignore transitive requires }
  515.             default { eval package-orig {$what} $args }
  516.             }
  517.         }
  518.         package unknown dummy
  519.         set origCmds [info commands]
  520.         set dir ""        ;# in case file is pkgIndex.tcl
  521.         set pkgs ""
  522.  
  523.         # Try to load the file if it has the shared library extension,
  524.         # otherwise source it.  It's important not to try to load
  525.         # files that aren't shared libraries, because on some systems
  526.         # (like SunOS) the loader will abort the whole application
  527.         # when it gets an error.
  528.  
  529.         if {[string compare [file extension $file] \
  530.             [info sharedlibextension]] == 0} {
  531.  
  532.             # The "file join ." command below is necessary.  Without
  533.             # it, if the file name has no \'s and we're on UNIX, the
  534.             # load command will invoke the LD_LIBRARY_PATH search
  535.             # mechanism, which could cause the wrong file to be used.
  536.  
  537.             load [file join . $file]
  538.             set type load
  539.         } else {
  540.             source $file
  541.             set type source
  542.         }
  543.         foreach ns [namespace children] {
  544.             namespace import ${ns}::*
  545.         }
  546.         foreach i [info commands] {
  547.             set cmds($i) 1
  548.         }
  549.         foreach i $origCmds {
  550.             catch {unset cmds($i)}
  551.  
  552.         }
  553.         foreach i [array names cmds] {
  554.             # reverse engineer which namespace a command comes from
  555.             set absolute [namespace origin $i]
  556.             if {[string compare ::$i $absolute] != 0} {
  557.             set cmds($absolute) 1
  558.             unset cmds($i)
  559.             }
  560.         }
  561.         foreach i [package names] {
  562.             if {([string compare [package provide $i] ""] != 0)
  563.                 && ([string compare $i Tcl] != 0)
  564.                 && ([string compare $i Tk] != 0)} {
  565.             lappend pkgs [list $i [package provide $i]]
  566.             }
  567.         }
  568.         }
  569.     } msg] {
  570.         tclLog "error while loading or sourcing $file: $msg"
  571.     }
  572.     foreach pkg [$c eval set pkgs] {
  573.         lappend files($pkg) [list $file [$c eval set type] \
  574.             [lsort [$c eval array names cmds]]]
  575.     }
  576.     interp delete $c
  577.     }
  578.     foreach pkg [lsort [array names files]] {
  579.     append index "\npackage ifneeded $pkg\
  580.         \[list tclPkgSetup \$dir [lrange $pkg 0 0] [lrange $pkg 1 1]\
  581.         [list $files($pkg)]\]"
  582.     }
  583.     set f [open pkgIndex.tcl w]
  584.     puts $f $index
  585.     close $f
  586.     cd $oldDir
  587. }
  588.  
  589. # tclPkgSetup --
  590. # This is a utility procedure use by pkgIndex.tcl files.  It is invoked
  591. # as part of a "package ifneeded" script.  It calls "package provide"
  592. # to indicate that a package is available, then sets entries in the
  593. # auto_index array so that the package's files will be auto-loaded when
  594. # the commands are used.
  595. #
  596. # Arguments:
  597. # dir -            Directory containing all the files for this package.
  598. # pkg -            Name of the package (no version number).
  599. # version -        Version number for the package, such as 2.1.3.
  600. # files -        List of files that constitute the package.  Each
  601. #            element is a sub-list with three elements.  The first
  602. #            is the name of a file relative to $dir, the second is
  603. #            "load" or "source", indicating whether the file is a
  604. #            loadable binary or a script to source, and the third
  605. #            is a list of commands defined by this file.
  606.  
  607. proc tclPkgSetup {dir pkg version files} {
  608.     global auto_index
  609.  
  610.     package provide $pkg $version
  611.     foreach fileInfo $files {
  612.     set f [lindex $fileInfo 0]
  613.     set type [lindex $fileInfo 1]
  614.     foreach cmd [lindex $fileInfo 2] {
  615.         if {$type == "load"} {
  616.         set auto_index($cmd) [list load [file join $dir $f] $pkg]
  617.         } else {
  618.         set auto_index($cmd) [list source [file join $dir $f]]
  619.         } 
  620.     }
  621.     }
  622. }
  623.  
  624. # tclMacPkgSearch --
  625. # The procedure is used on the Macintosh to search a given directory for files
  626. # with a TEXT resource named "pkgIndex".  If it exists it is sourced in to the
  627. # interpreter to setup the package database.
  628.  
  629. proc tclMacPkgSearch {dir} {
  630.     foreach x [glob -nocomplain [file join $dir *.shlb]] {
  631.     if [file isfile $x] {
  632.         set res [resource open $x]
  633.         foreach y [resource list TEXT $res] {
  634.         if {$y == "pkgIndex"} {source -rsrc pkgIndex}
  635.         }
  636.         resource close $res
  637.     }
  638.     }
  639. }
  640.  
  641. # tclPkgUnknown --
  642. # This procedure provides the default for the "package unknown" function.
  643. # It is invoked when a package that's needed can't be found.  It scans
  644. # the auto_path directories and their immediate children looking for
  645. # pkgIndex.tcl files and sources any such files that are found to setup
  646. # the package database.  (On the Macintosh we also search for pkgIndex
  647. # TEXT resources in all files.)
  648. #
  649. # Arguments:
  650. # name -        Name of desired package.  Not used.
  651. # version -        Version of desired package.  Not used.
  652. # exact -        Either "-exact" or omitted.  Not used.
  653.  
  654. proc tclPkgUnknown {name version {exact {}}} {
  655.     global auto_path tcl_platform env dir
  656.  
  657.     if ![info exists auto_path] {
  658.     return
  659.     }
  660.     if {[info exists dir]} {
  661.     set save_dir $dir
  662.     }
  663.     for {set i [expr [llength $auto_path] - 1]} {$i >= 0} {incr i -1} {
  664.     # we can't use glob in safe interps, so enclose the following
  665.     # in a catch statement
  666.     catch {
  667.         foreach file [glob -nocomplain [file join [lindex $auto_path $i] \
  668.             * pkgIndex.tcl]] {
  669.         set dir [file dirname $file]
  670.         if [catch {source $file} msg] {
  671.             tclLog "error reading package index file $file: $msg"
  672.         }
  673.         }
  674.         }
  675.     set dir [lindex $auto_path $i]
  676.     set file [file join $dir pkgIndex.tcl]
  677.     # safe interps usually don't have "file readable", nor stderr channel
  678.     if {[interp issafe] || [file readable $file]} {
  679.         if {[catch {source $file} msg] && ![interp issafe]}  {
  680.         tclLog "error reading package index file $file: $msg"
  681.         }
  682.     }
  683.     # On the Macintosh we also look in the resource fork 
  684.     # of shared libraries
  685.     # We can't use tclMacPkgSearch in safe interps because it uses glob
  686.     if {(![interp issafe]) && ($tcl_platform(platform) == "macintosh")} {
  687.         set dir [lindex $auto_path $i]
  688.         tclMacPkgSearch $dir
  689.         foreach x [glob -nocomplain [file join $dir *]] {
  690.             if [file isdirectory $x] {
  691.             set dir $x
  692.             tclMacPkgSearch $dir
  693.             }
  694.         }
  695.     }
  696.     }
  697.     if {[info exists save_dir]} {
  698.     set dir $save_dir
  699.     } else {
  700.     unset dir
  701.     }
  702. }
  703.